home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / MSDOS / (m)aal / CUTFILE2.PAS < prev    next >
Pascal/Delphi Source File  |  1987-10-11  |  6KB  |  206 lines

  1. PROGRAM Cutfile;
  2.  
  3.   {$U-}
  4.   {$C-}
  5.   {$I c:\pas\uti\util2.lib}
  6. TYPE
  7.   String50 = STRING[50];
  8. CONST
  9.   DataRecSize = 1;            (*  bytes *)
  10.   DiskSpaceFree : Real = 360400.0; (* Maximum size on disk *)
  11. VAR
  12.   Datafile : FILE;
  13.   OutFile : FILE;
  14.   Byte1 : Byte;
  15.   xzx : Char;
  16.   RecsRead, RecsWrote, buffsize,
  17.   NumberOfChunks : Integer;
  18.   Chunk, Datafilesize,
  19.   RecsAlreadyWritten : Real;
  20.   NoMoreRecs, FileisDone : Boolean;
  21.   DataArray : ARRAY[1..30000] OF Byte;
  22.   FN : STRING[1];
  23.   FN2 : STRING[2];
  24.   Outfilename, Inputfilename,
  25.   Destinationfilename : STRING[150];
  26.   pnr, I, num, FileNum : Integer;
  27.  
  28.   FUNCTION FreeDiskSpace(Drive : Char) : Real;
  29.  
  30.   TYPE
  31.     RegType = RECORD CASE Byte OF {Used for DOS calls.                 }
  32.       1 : (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer);
  33.       2 : (AL, AH, BL, BH, CL, CH, DL, DH : Byte);
  34.               END;
  35.  
  36.   VAR
  37.     Regpack : RegType;        {record for MsDos call}
  38.  
  39.   BEGIN                       (* GetFreeDiskSpace*)
  40.     WITH RegPack DO
  41.       BEGIN                   (* With RegPack *)
  42.         AH := $36;
  43.         CASE UpCase(Drive) OF
  44.           'A' : DL := 1;
  45.           'B' : DL := 2;
  46.           'C' : DL := 3;
  47.           'D' : DL := 4;
  48.           'E' : DL := 5;
  49.           'F' : DL := 6;
  50.           'G' : DL := 7;
  51.           'H' : DL := 8;
  52.           'I' : DL := 9;
  53.           'J' : DL := 10;
  54.         ELSE Dl := 0;
  55.         END                   (* case *)
  56.       END;                    (* With RegPack *)
  57.     MsDos(regpack);
  58.     WITH regpack DO
  59.       BEGIN
  60.         IF AX = $FFFF THEN    (* error has occured *)
  61.           BEGIN
  62.             WriteLn('Dos reports Invalid Drive or other error');
  63.             WriteLn('Program Execution Terminated');
  64.             Halt;             (*Program execution stops here*)
  65.           END;
  66.         FreeDiskSpace := 1.0*RegPack.AX*RegPack.BX*RegPack.CX*1.0;
  67.       END;
  68.   END;                        (* FreeDiskSpace *)
  69.  
  70.  
  71.   FUNCTION ReadFileName(Description : String50) : String80;
  72.     (**************************************************************************)
  73.   VAR
  74.     Infilename : String80;
  75.     FileExists : Boolean;
  76.   BEGIN
  77.     REPEAT
  78.       WriteLn('Please enter the name of the ', description, ' file ');
  79.       ReadLn(infilename);
  80.       IF Exist(infilename) THEN
  81.         BEGIN
  82.           FileExists := True;
  83.         END
  84.       ELSE
  85.         BEGIN
  86.           FileExists := False;
  87.           WriteLn('File not Found!! Press any key or Ctrl C to abort');
  88.           Read(Kbd, xzx);
  89.         END;
  90.     UNTIL (FileExists OR (Ord(xzx) = $03));
  91.     IF Ord(xzx) = $03 THEN
  92.       BEGIN
  93.         WriteLn('Program Terminated');
  94.         Halt;
  95.       END;
  96.  
  97.     ReadFileName := Infilename;
  98.   END;                        (* ReadFileName*)
  99.  
  100.   FUNCTION WriteFileName(Description : String50) : String80;
  101.     (**************************************************************************)
  102.   VAR
  103.     Infilename : String80;
  104.     FileExists : Boolean;
  105.   BEGIN
  106.     REPEAT
  107.       WriteLn('Please enter the name of the ', description, ' file ');
  108.       ReadLn(infilename);
  109.       IF Exist(infilename) THEN
  110.         FileExists := True
  111.       ELSE
  112.         BEGIN
  113.           FileExists := False;
  114.         END;
  115.     UNTIL (NOT FileExists OR (Ord(infilename[1]) = $03));
  116.     IF Ord(infilename[1]) = $03 THEN Halt;
  117.     WriteFileName := Infilename;
  118.   END;                        (* ReadFileName*)
  119.  
  120.  
  121.   PROCEDURE WriteFile(FileNum : Integer; NumberOfBytesAvailable : Real);
  122.     (**************************************************************************)
  123.   BEGIN                       (*WriteFile*)
  124.     IF FileNum < 10 THEN
  125.       BEGIN
  126.         Str(FileNum, FN);
  127.         Outfilename := Destinationfilename+'.'+FN;
  128.       END
  129.     ELSE
  130.       BEGIN
  131.         Str(filenum, FN2);
  132.         Outfilename := Destinationfilename+'.'+FN2;
  133.       END;
  134.     WriteLn('There are ', NumberOfBytesAvailable, ' available');
  135.     WriteLn('Writing ', Outfilename);
  136.     Assign(Outfile, Outfilename);
  137.     Rewrite(outfile, 1);
  138.     LongSeek(Datafile, RecsAlreadyWritten);
  139.     IF NumberOfBytesAvailable > 30000 THEN
  140.       Buffsize := 30000
  141.     ELSE
  142.       BuffSize := Trunc(NumberOfBytesAvailable);
  143.     Chunk := 0;
  144.     REPEAT
  145.       BlockRead(datafile, DataArray, Buffsize, Recsread);
  146.       BlockWrite(outfile, DataArray, RecsRead);
  147.       chunk := RecsRead+Chunk;
  148.       WriteLn('Read ', RecsRead:6, ' recs and wrote ', Chunk:6);
  149.       IF Abs(NumberOfBytesAvailable-chunk) < 30000 THEN
  150.         Buffsize := Trunc(NumberOfBytesAvailable-chunk);
  151.     UNTIL ((chunk >= NumberOfBytesAvailable) OR (RecsRead < 1));
  152.     RecsAlreadyWritten := RecsAlreadyWritten+Chunk;
  153.     Close(outfile);
  154.     IF RecsAlreadyWritten >= DataFileSize THEN
  155.       FileIsDone := True
  156.     ELSE
  157.       FileIsDone := False;
  158.   END;                        (* WriteFile *)
  159.  
  160.   PROCEDURE TransferFileToFloppies;
  161.     (**************************************************************************)
  162.   VAR
  163.     I : Integer;
  164.     Drive : Char;
  165.  
  166.   BEGIN                       (*TransferPartOfFile*)
  167.     RecsAlreadyWritten := 0;
  168.     Assign(datafile, inputfilename);
  169.     Reset(datafile, 1);
  170.     DataFileSize := LongFileSize(datafile);
  171.     FOR I := 1 TO 3 DO
  172.       BEGIN
  173.         IF DestinationFileName[I] = ':' THEN
  174.           BEGIN
  175.             Drive := DestinationFileName[Pred(I)];
  176.             i := 3
  177.           END;
  178.       END;
  179.     FileNum := 1;
  180.     REPEAT
  181.       WriteLn('Please get Destination drive ready.. Press any key when ready');
  182.       Read(Kbd, xzx);
  183.       IF Ord(xzx) = $03 THEN
  184.         BEGIN
  185.           Close(datafile);
  186.           Close(Outfile);
  187.           WriteLn('Program Terminated by Ctrl C');
  188.           Halt;
  189.         END;
  190.       DiskSpaceFree := FreeDiskSpace(Drive);
  191.       WriteFile(FileNum, DiskSpaceFree);
  192.       Filenum := Succ(fileNum);
  193.     UNTIL FileIsDone;
  194.     Close(Datafile);
  195.   END;
  196.  
  197.  
  198.  
  199.  
  200. BEGIN
  201.   xzx := ' ';
  202.   InputFileName := ReadFileName('input (include Extension)');
  203.   DestinationFileName := WriteFileName('Destination (include path, no extension');
  204.   TransferFileToFloppies;
  205. END.
  206.